home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / manager.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  27KB  |  662 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;; Window Manager Property functions
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package 'xlib :use '(lisp))
  22.  
  23. (export '(wm-name        ;These are all setf'able accessor functions
  24.       wm-icon-name
  25.       wm-client-machine
  26.       wm-command
  27.       wm-hints
  28.       wm-normal-hints
  29.       wm-zoom-hints
  30.       icon-sizes
  31.  
  32.       wm-size-hints
  33.       wm-size-hints-p
  34.       make-wm-size-hints
  35.       wm-size-hints-user-specified-position-p
  36.       wm-size-hints-user-specified-size-p
  37.       wm-size-hints-x
  38.       wm-size-hints-y
  39.       wm-size-hints-width
  40.       wm-size-hints-height
  41.       wm-size-hints-min-width
  42.       wm-size-hints-min-height
  43.       wm-size-hints-max-width
  44.       wm-size-hints-max-height
  45.       wm-size-hints-width-inc
  46.       wm-size-hints-height-inc
  47.       wm-size-hints-min-aspect
  48.       wm-size-hints-max-aspect
  49.  
  50.       wm-hints
  51.       wm-hints-p
  52.       make-wm-hints
  53.       wm-hints-input
  54.       wm-hints-initial-state
  55.       wm-hints-icon-pixmap
  56.       wm-hints-icon-window
  57.       wm-hints-icon-x
  58.       wm-hints-icon-y
  59.       wm-hints-icon-mask
  60.       wm-hints-window-group
  61.       wm-hints-flags
  62.  
  63.       transient-for
  64.  
  65.       set-standard-properties
  66.  
  67.       get-wm-class
  68.       set-wm-class
  69.       get-standard-colormap
  70.       set-standard-colormap
  71.  
  72.       cut-buffer   ;; Setf'able
  73.       rotate-cut-buffers
  74.       ))
  75.  
  76. (defun wm-name (window)
  77.   (declare (type window window))
  78.   (declare-values string)
  79.   (get-property window :wm_name :type :string :result-type 'string :transform #'card8->char))
  80.  
  81. (defsetf wm-name (window) (name)
  82.   (declare (type window window))
  83.   (declare-values string)
  84.   `(set-string-property ,window :wm_name ,name))
  85.  
  86. (defun set-string-property (window property string)
  87.   (declare (type window window)
  88.        (type keyword property)
  89.        (type stringable string))
  90.   (change-property window property (string string) :string 8 :transform #'char->card8)
  91.   string)
  92.  
  93. (defun wm-icon-name (window)
  94.   (declare (type window window))
  95.   (declare-values string)
  96.   (get-property window :wm_icon_name :type :string
  97.         :result-type 'string :transform #'card8->char))
  98.  
  99. (defsetf wm-icon-name (window) (name)
  100.   `(set-string-property ,window :wm_icon_name ,name))
  101.  
  102. (defun wm-client-machine (window)
  103.   (declare (type window window))
  104.   (declare-values string)
  105.   (get-property window :wm_client_machine :type :string
  106.         :result-type 'string :transform #'card8->char))
  107.  
  108. (defsetf wm-client-machine (window) (name)
  109.   `(set-string-property ,window :wm_client_machine ,name))
  110.  
  111. (defun get-wm-class (window)
  112.   (declare (type window window))
  113.   (declare-values (or null name-string) (or null class-string))
  114.   (let ((value (get-property window :wm_class :type :string
  115.                  :result-type 'string :transform #'card8->char)))
  116.     (declare (type (or null string) value))
  117.     (when value
  118.       (let* ((name-len (position #.(int-char 0) (the string value)))
  119.          (name (subseq (the string value) 0 name-len))
  120.          (class (subseq (the string value) (1+ name-len) (1- (length value)))))
  121.     (values (and (plusp (length name)) name)
  122.         (and (plusp (length class)) class))))))
  123.  
  124. (defun set-wm-class (window resource-name resource-class)
  125.   (declare (type window window)
  126.        (type (or null stringable) resource-name resource-class))
  127.   (set-string-property window :wm_class
  128.                (concatenate 'string
  129.                     (string (or resource-name ""))
  130.                     #.(make-string 1 :initial-element (int-char 0))
  131.                     (string (or resource-class ""))
  132.                     #.(make-string 1 :initial-element (int-char 0))))
  133.   (values))
  134.  
  135. (defun wm-command (window)
  136.   ;; Returns a list whose car is the command and 
  137.   ;; whose cdr is the list of arguments
  138.   (declare (type window window))
  139.   (declare-values list)
  140.   (do* ((command-string (get-property window :wm_command :type :string
  141.                       :result-type 'string :transform #'card8->char))
  142.     (command nil)
  143.     (start 0 (1+ end))
  144.     (end 0)
  145.     (len (length command-string)))
  146.        ((>= start len) (nreverse command))
  147.     (setq end (position #.(int-char 0) command-string :start start))
  148.     (push (subseq command-string start end) command)))
  149.  
  150. (defsetf wm-command set-wm-command)
  151. (defun set-wm-command (window command)
  152.   ;; Uses PRIN1 to a string-stream with the following bindings:
  153.   ;; (*print-length* nil) (*print-level* nil) (*print-radix* nil)
  154.   ;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp))
  155.   ;; each element of command is seperated with NULL characters.
  156.   ;; This enables (mapcar #'read-from-string (wm-command window))
  157.   ;; to recover a lisp command.
  158.   (declare (type window window)
  159.        (type list command))
  160.   (set-string-property window :wm_command
  161.                (with-output-to-string (stream)
  162.              (let ((*print-length* nil)
  163.                    (*print-level* nil)
  164.                    (*print-radix* nil)
  165.                    (*print-base* 10.)
  166.                    (*print-array* t)
  167.                    (*package* (find-package 'lisp))
  168.                    #+ti (ticl:*print-structure* t))
  169.                (dolist (c command)
  170.                  (prin1 c stream)
  171.                  (write-char #.(int-char 0) stream)))))
  172.   command)
  173.  
  174. ;;-----------------------------------------------------------------------------
  175. ;; WM_HINTS
  176.  
  177. (defstruct wm-hints
  178.   (input nil :type (or null (member :off :on)))
  179.   (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive)))
  180.   (icon-pixmap nil :type (or null pixmap))
  181.   (icon-window nil :type (or null window))
  182.   (icon-x nil :type (or null card16))
  183.   (icon-y nil :type (or null card16))
  184.   (icon-mask nil :type (or null pixmap))
  185.   (window-group nil :type (or null resource-id))
  186.   (flags 0 :type card32)    ;; Extension-hook.  Exclusive-Or'ed with the FLAGS field
  187.   ;; may be extended in the future
  188.   )
  189.  
  190. (defun wm-hints (window)
  191.   (declare (type window window))
  192.   (declare-values wm-hints)
  193.   (let ((prop (get-property window :wm_hints :type :wm_hints :result-type 'vector)))
  194.     (when prop
  195.       (decode-wm-hints prop (window-display window)))))
  196.  
  197. (defsetf wm-hints set-wm-hints)
  198. (defun set-wm-hints (window wm-hints)
  199.   (declare (type window window)
  200.        (type wm-hints wm-hints))
  201.   (declare-values wm-hints)
  202.   (change-property window :wm_hints (encode-wm-hints wm-hints) :wm_hints 32)
  203.   wm-hints)
  204.  
  205. (defun decode-wm-hints (vector display)
  206.   (declare (type (simple-vector 9) vector)
  207.        (type display display))
  208.   (declare-values wm-hints)
  209.   (let ((input-hint 0)
  210.     (state-hint 1)
  211.     (icon-pixmap-hint 2)
  212.     (icon-window-hint 3)
  213.     (icon-position-hint 4)
  214.     (icon-mask-hint 5)
  215.     (window-group-hint 6)
  216.     )
  217.     (let ((flags (aref vector 0))
  218.       (hints (make-wm-hints)))
  219.       (declare (type card32 flags)
  220.            (type wm-hints hints))
  221.       (setf (wm-hints-flags hints) flags)
  222.       (compiler-let ((*buffer* 'display))
  223.     (when (logbitp input-hint flags)
  224.       (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1))))
  225.     (when (logbitp state-hint flags)
  226.       (setf (wm-hints-initial-state hints)
  227.         (decode-type (member :dont-care :normal :zoom :iconic :inactive)
  228.                  (aref vector 2))))
  229.     (when (logbitp icon-pixmap-hint flags)
  230.       (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
  231.     (when (logbitp icon-window-hint flags)
  232.       (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
  233.     (when (logbitp icon-position-hint flags)
  234.       (setf (wm-hints-icon-x hints) (aref vector 5)
  235.         (wm-hints-icon-y hints) (aref vector 6)))
  236.     (when (logbitp icon-mask-hint flags)
  237.       (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
  238.     (when (and (logbitp window-group-hint flags) (> (length vector) 7))
  239.       (setf (wm-hints-window-group hints) (aref vector 8)))
  240.     hints))))
  241.  
  242.  
  243. (defun encode-wm-hints (wm-hints)
  244.   (declare (type wm-hints wm-hints))
  245.   (declare-values simple-vector)
  246.   (let ((input-hint         #b1)
  247.     (state-hint         #b10)
  248.     (icon-pixmap-hint   #b100)
  249.     (icon-window-hint   #b1000)
  250.     (icon-position-hint #b10000)
  251.     (icon-mask-hint     #b100000)
  252.     (window-group-hint  #b1000000)
  253.     (mask               #b1111111)
  254.     )
  255.     (let ((vector (make-array 9 :initial-element 0))
  256.       (flags 0))
  257.       (declare (type (simple-vector 9) vector)
  258.            (type card16 flags))
  259.       (when (wm-hints-input wm-hints)
  260.     (setf flags input-hint
  261.           (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
  262.       (when (wm-hints-initial-state wm-hints)
  263.     (setf flags (logior flags state-hint)
  264.           (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
  265.                        (wm-hints-initial-state wm-hints))))
  266.       (when (wm-hints-icon-pixmap wm-hints)
  267.     (setf flags (logior flags icon-pixmap-hint)
  268.           (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
  269.       (when (wm-hints-icon-window wm-hints)
  270.     (setf flags (logior flags icon-window-hint)
  271.           (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
  272.       (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints))
  273.     (setf flags (logior flags icon-position-hint)
  274.           (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
  275.           (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
  276.       (when (wm-hints-icon-mask wm-hints)
  277.     (setf flags (logior flags icon-mask-hint)
  278.           (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
  279.       (when (wm-hints-window-group wm-hints)
  280.     (setf flags (logior flags window-group-hint)
  281.           (aref vector 8) (wm-hints-window-group wm-hints)))
  282.       (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask)))
  283.       vector)))
  284.  
  285. ;;-----------------------------------------------------------------------------
  286. ;; WM_SIZE_HINTS
  287.  
  288. (defstruct wm-size-hints
  289.   ;; Defaulted T to put the burden of remembering these on widget programmers.
  290.   (user-specified-position-p t :type boolean) ;; True when user specified x y
  291.   (user-specified-size-p t :type boolean)     ;; True when user specified width height
  292.   (x nil :type (or null int16))
  293.   (y nil :type (or null int16))
  294.   (width nil :type (or null card16))
  295.   (height nil :type (or null card16))
  296.   (min-width nil :type (or null card16))
  297.   (min-height nil :type (or null card16))
  298.   (max-width nil :type (or null card16))
  299.   (max-height nil :type (or null card16))
  300.   (width-inc nil :type (or null card16))
  301.   (height-inc nil :type (or null card16))
  302.   (min-aspect nil :type (or null number))
  303.   (max-aspect nil :type (or null number)))
  304.  
  305. (defun wm-normal-hints (window)
  306.   (declare (type window window))
  307.   (declare-values wm-size-hints)
  308.   (decode-wm-size-hints (get-property window :wm_normal_hints :type :wm_size_hints :result-type 'vector)))
  309.  
  310. (defsetf wm-normal-hints set-wm-normal-hints)
  311. (defun set-wm-normal-hints (window hints)
  312.   (declare (type window window)
  313.        (type wm-size-hints hints))
  314.   (declare-values wm-size-hints)
  315.   (change-property window :wm_normal_hints (encode-wm-size-hints hints) :wm_size_hints 32)
  316.   hints)
  317.  
  318. (defun wm-zoom-hints (window)
  319.   (declare (type window window))
  320.   (declare-values wm-size-hints)
  321.   (decode-wm-size-hints (get-property window :wm_zoom_hints :type :wm_size_hints :result-type 'vector)))
  322.  
  323. (defsetf wm-zoom-hints set-wm-zoom-hints)
  324. (defun set-wm-zoom-hints (window hints)
  325.   (declare (type window window)
  326.        (type wm-size-hints hints))
  327.   (declare-values wm-size-hints)
  328.   (change-property window :wm_zoom_hints (encode-wm-size-hints hints) :wm_size_hints 32)
  329.   hints)
  330.  
  331. (defun decode-wm-size-hints (vector)
  332.   (declare (type (or null (simple-vector 15)) vector))
  333.   (declare-values (or null wm-size-hints))
  334.   (when vector
  335.     (let ((usposition 0)            ;User Specified position
  336.       (ussize 1)                ;User Specified size
  337.       (pposition 2)                ;Program specified position
  338.       (psize 3)                ;Program specified size
  339.       (pminsize 4)                ;Program specified minimum size
  340.       (pmaxsize 5)                ;Program specified maximum size
  341.       (presizeinc 6)            ;Program specified resize increments
  342.       (paspect 7)                ;Program specfied min and max aspect ratios
  343.       )
  344.       (let ((flags (aref vector 0))
  345.         (hints (make-wm-size-hints)))
  346.     (declare (type card16 flags)
  347.          (type wm-size-hints hints))
  348.     (when (or (logbitp usposition flags)
  349.           (logbitp pposition flags))
  350.       (setf (wm-size-hints-user-specified-position-p hints) (logbitp usposition flags)
  351.         (wm-size-hints-x hints) (aref vector 1)
  352.         (wm-size-hints-y hints) (aref vector 2)))
  353.     (when (or (logbitp ussize flags)
  354.           (logbitp psize flags))
  355.       (setf (wm-size-hints-user-specified-size-p hints) (logbitp usposition flags)
  356.         (wm-size-hints-width hints) (aref vector 3)
  357.         (wm-size-hints-height hints) (aref vector 4)))
  358.     (when (logbitp pminsize flags)
  359.       (setf (wm-size-hints-min-width hints) (aref vector 5)
  360.         (wm-size-hints-min-height hints) (aref vector 6)))
  361.     (when (logbitp pmaxsize flags)
  362.       (setf (wm-size-hints-max-width hints) (aref vector 7)
  363.         (wm-size-hints-max-height hints) (aref vector 8)))
  364.     (when (logbitp presizeinc flags)
  365.       (setf (wm-size-hints-width-inc hints) (aref vector 9)
  366.         (wm-size-hints-height-inc hints) (aref vector 10)))
  367.     (when (logbitp paspect flags)
  368.       (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12))
  369.         (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14))))
  370.     hints))))
  371.  
  372. (defun encode-wm-size-hints (hints)
  373.   (declare (type wm-size-hints hints))
  374.   (declare-values simple-vector)
  375.   (let ((usposition #b1)            ;User Specified position
  376.     (ussize     #b10)            ;User Specified size
  377.     (pposition  #b100)            ;Program specified position
  378.     (psize      #b1000)            ;Program specified size
  379.     (pminsize   #b10000)            ;Program specified minimum size
  380.     (pmaxsize   #b100000)            ;Program specified maximum size
  381.     (presizeinc #b1000000)            ;Program specified resize increments
  382.     (paspect    #b10000000)            ;Program specfied min and max aspect ratios
  383.     )
  384.     (let ((vector (make-array 15 :initial-element 0))
  385.       (flags 0))
  386.       (declare (type (simple-vector 15) vector)
  387.            (type card16 flags))
  388.       (when (and (wm-size-hints-x hints) (wm-size-hints-y hints))
  389.     (setq flags (if (wm-size-hints-user-specified-position-p hints) usposition pposition))
  390.     (setf (aref vector 1) (wm-size-hints-x hints)
  391.           (aref vector 2) (wm-size-hints-y hints)))
  392.       (when (and (wm-size-hints-width hints) (wm-size-hints-height hints))
  393.     (setf flags (logior flags (if (wm-size-hints-user-specified-position-p hints) ussize psize))
  394.           (aref vector 3) (wm-size-hints-width hints)
  395.           (aref vector 4) (wm-size-hints-height hints)))
  396.       
  397.       (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints))
  398.     (setf flags (logior flags pminsize)
  399.           (aref vector 5) (wm-size-hints-min-width hints)
  400.           (aref vector 6) (wm-size-hints-min-height hints)))
  401.       (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints))
  402.     (setf flags (logior flags pmaxsize)
  403.           (aref vector 7) (wm-size-hints-max-width hints)
  404.           (aref vector 8) (wm-size-hints-max-height hints)))
  405.       (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints))
  406.     (setf flags (logior flags presizeinc)
  407.           (aref vector 9) (wm-size-hints-width-inc hints)
  408.           (aref vector 10) (wm-size-hints-height-inc hints)))
  409.       (let ((min-aspect (wm-size-hints-min-aspect hints))
  410.         (max-aspect (wm-size-hints-max-aspect hints)))
  411.     (when (and min-aspect max-aspect)
  412.       (setf flags (logior flags paspect)
  413.         min-aspect (rationalize min-aspect)
  414.         max-aspect (rationalize max-aspect)
  415.         (aref vector 11) (numerator min-aspect)
  416.         (aref vector 12) (denominator min-aspect)
  417.         (aref vector 13) (numerator max-aspect)
  418.         (aref vector 14) (denominator max-aspect))))
  419.       (setf (aref vector 0) flags)
  420.       vector)))
  421.  
  422. ;;-----------------------------------------------------------------------------
  423. ;; Icon_Size
  424.  
  425. ;; Use the same intermediate structure as WM_SIZE_HINTS
  426.  
  427. (defun icon-sizes (window)
  428.   (declare (type window window))
  429.   (declare-values wm-size-hints)
  430.   (let ((vector (get-property window :wm_icon_size :type :wm_icon_size :result-type 'vector)))
  431.     (declare (type (or null (simple-vector 6)) vector))
  432.     (when vector
  433.       (make-wm-size-hints
  434.     :min-width (aref vector 0)
  435.     :min-height (aref vector 1)
  436.     :max-width (aref vector 2)
  437.     :max-height (aref vector 3)
  438.     :width-inc (aref vector 4)
  439.     :height-inc (aref vector 5)))))
  440.   
  441. (defsetf icon-sizes set-icon-sizes)
  442. (defun set-icon-sizes (window wm-size-hints)
  443.   (declare (type window window)
  444.        (type wm-size-hints wm-size-hints))
  445.   (let ((vector (vector (wm-size-hints-min-width wm-size-hints)
  446.             (wm-size-hints-min-height wm-size-hints)
  447.             (wm-size-hints-max-width wm-size-hints)
  448.             (wm-size-hints-max-height wm-size-hints)
  449.             (wm-size-hints-width-inc wm-size-hints)
  450.             (wm-size-hints-height-inc wm-size-hints))))
  451.     (change-property window :wm_icon_size vector :wm_icon_size 32)
  452.     wm-size-hints))
  453.  
  454. ;;-----------------------------------------------------------------------------
  455. ;; Transient-For
  456.  
  457. (defun transient-for (window)
  458.   (let ((prop (get-property window :wm_transient_for :type :window :result-type 'list)))
  459.     (and prop (lookup-window (window-display window) (car prop)))))
  460.  
  461. (defsetf transient-for set-transient-for)
  462. (defun set-transient-for (window transient)
  463.   (declare (type window window transient))
  464.   (change-property window :wm_transient_for (list (window-id transient)) :window 32)
  465.   transient)
  466.  
  467. ;;-----------------------------------------------------------------------------
  468. ;; Set-Standard-Properties
  469.  
  470. (defun set-standard-properties (window &rest options &key 
  471.                 name icon-name resource-name resource-class command
  472.                 client-machine hints normal-hints zoom-hints
  473.                 ;; the following are used for wm-normal-hints
  474.                 user-specified-position-p
  475.                 user-specified-size-p
  476.                 x y width height min-width min-height max-width max-height
  477.                 width-inc height-inc min-aspect max-aspect
  478.                 ;; the following are used for wm-hints
  479.                 input initial-state icon-pixmap icon-window
  480.                 icon-x icon-y icon-mask window-group)
  481.   ;; Set properties for WINDOW.
  482.   (declare (type window window)
  483.        (type (or null stringable) name icon-name resource-name resource-class client-machine)
  484.        (type (or null list) command)
  485.        (type (or null wm-hints) hints)
  486.        (type (or null wm-size-hints) normal-hints zoom-hints)
  487.        (type (or null boolean) user-specified-position-p user-specified-size-p)
  488.        (type (or null int16) x y)
  489.        (type (or null card16) width height min-width min-height max-width max-height width-inc height-inc)
  490.        (type (or null number) min-aspect max-aspect)
  491.        (type (or null (member :off :on)) input)
  492.        (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state)
  493.        (type (or null pixmap) icon-pixmap icon-mask)
  494.        (type (or null window) icon-window)
  495.        (type (or null card16) icon-x icon-y)
  496.        (type (or null resource-id) window-group))
  497.   (when name (setf (wm-name window) name))
  498.   (when icon-name (setf (wm-icon-name window) icon-name))
  499.   (when client-machine (setf (wm-client-machine window) client-machine))
  500.   (when (or resource-name resource-class)
  501.     (set-wm-class window resource-name resource-class))
  502.   (when command (setf (wm-command window) command))
  503.   ;; WM-HINTS
  504.   (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window
  505.                 :icon-x :icon-y :icon-mask :window-group))
  506.     (when (getf options arg) (return t)))
  507.       (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints))))
  508.     (when input (setf (wm-hints-input wm-hints) input))
  509.     (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state))
  510.     (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap))
  511.     (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window))
  512.     (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x))
  513.     (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y))
  514.     (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask))
  515.     (when window-group (setf (wm-hints-input wm-hints) window-group))
  516.     (setf (wm-hints window) wm-hints))
  517.     (when hints (setf (wm-hints window) hints)))
  518.   ;; WM-NORMAL-HINTS
  519.   (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height
  520.             :width-inc :height-inc :min-aspect :max-aspect
  521.             :user-specified-position-p :user-specified-size-p))
  522.     (when (getf options arg) (return t)))
  523.       (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints))))
  524.     (when x (setf (wm-size-hints-x size) x))
  525.     (when y (setf (wm-size-hints-y size) y))
  526.     (when width (setf (wm-size-hints-width size) width))
  527.     (when height (setf (wm-size-hints-height size) height))
  528.     (when min-width (setf (wm-size-hints-min-width size) min-width))
  529.     (when min-height (setf (wm-size-hints-min-height size) min-height))
  530.     (when max-width (setf (wm-size-hints-max-width size) max-width))
  531.     (when max-height (setf (wm-size-hints-max-height size) max-height))
  532.     (when width-inc (setf (wm-size-hints-width-inc size) width-inc))
  533.     (when height-inc (setf (wm-size-hints-height-inc size) height-inc))
  534.     (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect))
  535.     (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect))
  536.     (when user-specified-position-p (setf (wm-size-hints-user-specified-position-p size)
  537.                           user-specified-position-p))
  538.     (when user-specified-size-p (setf (wm-size-hints-user-specified-size-p size)
  539.                       user-specified-size-p))
  540.     (setf (wm-normal-hints window) size))
  541.     (when normal-hints (setf (wm-normal-hints window) normal-hints)))
  542.   (when zoom-hints (setf (wm-zoom-hints window) zoom-hints))
  543.   )
  544.  
  545. ;;-----------------------------------------------------------------------------
  546. ;; Colormaps
  547.  
  548. (defun get-standard-colormap (window property)
  549.   (declare (type window window)
  550.        (type (member :rgb_default_map :rgb_best_map :rgb_red_map
  551.              :rgb_green_map :rgb_blue_map) property))
  552.   (declare-values colormap base-pixel max-color mult-color)
  553.   (let ((prop (get-property window property :type :rgb_color_map :result-type 'vector)))
  554.     (declare (type (or null (simple-vector 8)) prop))
  555.     (when prop
  556.       (values (lookup-colormap (window-display window) (aref prop 0))
  557.           (aref prop 7)            ;Base Pixel
  558.           (make-color :red   (card16->rgb-val (aref prop 1))    ;Max Color
  559.               :green (card16->rgb-val (aref prop 3))
  560.               :blue  (card16->rgb-val (aref prop 5)))
  561.           (make-color :red   (card16->rgb-val (aref prop 2))    ;Mult color
  562.               :green (card16->rgb-val (aref prop 4))
  563.               :blue  (card16->rgb-val (aref prop 6)))
  564.           ))))
  565.  
  566. (defun set-standard-colormap (window property colormap base-pixel max-color mult-color)
  567.   (declare (type window window)
  568.        (type (member :rgb_default_map :rgb_best_map :rgb_red_map
  569.              :rgb_green_map :rgb_blue_map) property)
  570.        (type colormap colormap)
  571.        (type pixel base-pixel)
  572.        (type color max-color mult-color))
  573.   (let ((prop (vector (encode-type colormap colormap)
  574.               (encode-type rgb-val (color-red max-color))
  575.               (encode-type rgb-val (color-red mult-color))
  576.               (encode-type rgb-val (color-green max-color))
  577.               (encode-type rgb-val (color-green mult-color))
  578.               (encode-type rgb-val (color-blue max-color))
  579.               (encode-type rgb-val (color-blue mult-color))
  580.               base-pixel)))
  581.     (change-property window property prop :rgb_color_map 32)))
  582.  
  583. ;;-----------------------------------------------------------------------------
  584. ;; Cut-Buffers
  585.  
  586. (defun cut-buffer (display &key (buffer 0) (type :string) (result-type 'string)
  587.            (transform #'card8->char) (start 0) end)
  588.   ;; Return the contents of cut-buffer BUFFER
  589.   (declare (type display display)
  590.        (type (integer 0 7) buffer)
  591.        (type xatom type)
  592.        (type array-index start)
  593.        (type (or null array-index) end)
  594.        (type t result-type)            ;a sequence type
  595.        (type (or null (function (integer) t)) transform))
  596.   (declare-values sequence type format bytes-after)
  597.   (let* ((root (screen-root (first (display-roots display))))
  598.      (property (aref '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
  599.                 :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)
  600.              buffer)))
  601.     (get-property root property :type type :result-type result-type
  602.           :start start :end end :transform transform)))
  603.  
  604. ;; Implement the following:
  605. ;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8)
  606. ;;                    (transform #'char->card8) (start 0) end) (data)
  607. ;; In order to avoid having to pass positional parameters to set-cut-buffer,
  608. ;; We've got to do the following.  WHAT A PAIN...
  609. (define-setf-method cut-buffer (display &rest option-list)
  610.   (do* ((options (copy-list option-list))
  611.     (option options (cddr option))
  612.     (store (gensym))
  613.     (dtemp (gensym))
  614.     (temps (list dtemp))
  615.     (values (list display)))
  616.        ((endp option)
  617.     (values (nreverse temps)
  618.         (nreverse values)
  619.         (list store)
  620.         `(set-cut-buffer ,store ,dtemp ,@options)
  621.         `(cut-buffer ,@options)))
  622.     (unless (member (car option) '(:buffer :type :format :start :end :transform))
  623.       (error "Keyword arg ~s isn't recognized" (car option)))
  624.     (let ((x (gensym)))
  625.       (push x temps)
  626.       (push (cadr option) values)
  627.       (setf (cadr option) x))))
  628.  
  629. (defun set-cut-buffer (data display &key (buffer 0) (type :string) (format 8)
  630.                (start 0) end (transform #'char->card8))
  631.   (declare (type sequence data)
  632.        (type display display)
  633.        (type (integer 0 7) buffer)
  634.        (type xatom type)
  635.        (type (member 8 16 32) format)
  636.        (type array-index start)
  637.        (type (or null array-index) end)
  638.        (type (or null (function (integer) t)) transform))
  639.   (let* ((root (screen-root (first (display-roots display))))
  640.      (property (aref '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
  641.                 :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)
  642.              buffer)))
  643.     (change-property root property data type format :transform transform :start start :end end)
  644.     data))
  645.  
  646. (defun rotate-cut-buffers (display &optional (delta 1) (careful-p t))
  647.   ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
  648.   ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors.
  649.   (declare (type display display)
  650.        (type int16 delta)
  651.        (type boolean careful-p))
  652.   (let* ((root (screen-root (first (display-roots display))))
  653.      (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
  654.              :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)))
  655.     (when careful-p
  656.       (let ((props (list-properties root)))
  657.     (dotimes (i 8)
  658.       (unless (member (aref buffers i) props)
  659.         (setf (cut-buffer display :buffer i) "")))))
  660.     (rotate-properties root buffers delta)))
  661.  
  662.